;;;; JDBC abstractions from Common Lisp
(in-package :ws-sql)

;; (defconstant +java-null+ 
;;   (make-immediate-object nil :ref)
;;   "a 'null' reference Java object")

(defun get-procedures-as-result-set 
    (&key 
     (catalog +java-null+) 
     (schema-pattern +java-null+) 
     (procedure-name-pattern "%"))
  "Get all database procedures matching CATALOG SCHEMA-PATTERN
   PROCEDURE-NAME-PATTERN"
  (when (null catalog)
    (setf catalog ""))
  (when (null schema-pattern)
    (setf schema-pattern ""))
  (if *metadata*
       (#"getProcedures" *metadata* catalog schema-pattern
			 procedure-name-pattern)
       (error "No JDBC metadata reference in *metadata* to work with.")))


(defvar *last-procedures* nil
  "The last result resturned by GET-PROCEDURES.")

(defun get-procedures (&key 
		       (catalog +java-null+) 
		       (schema-pattern +java-null+) 
		       (procedure-name-pattern "%"))      
  "Return all SQL stored procedures matching CATALOG SCHEMA PROCEDURE."
  (setf *last-procedures*
	(serialize-result-set 
	 (get-procedures-as-result-set 
	  :catalog catalog 
	  :schema-pattern schema-pattern
	  :procedure-name-pattern procedure-name-pattern))))

(defun get-procedures-names (&key 
			     (catalog +java-null+) 
			     (schema-pattern +java-null+) 
			     (procedure-name-pattern "%"))      
  "Return all SQL stored procedure names matching CATALOG SCHEMA
			     PROCEDURE."
  (let ((procedures  
	 (transcribe-result-set-as-strings 
	  (get-procedures-as-result-set 
	   :catalog catalog 
	   :schema-pattern schema-pattern
	   :procedure-name-pattern procedure-name-pattern))))
    (loop :for row :in procedures 
       :collecting (list (first row) (second row) (third row)))))
    
  
  
(defun transcribe-result-set-as-strings (result-set)
  "Return a java.sql.ResultSet as list of row lists"
  (declare (ignore column-names))
  (let* ((result-set-metadata (#"getMetaData" result-set))
	 (column-count (#"getColumnCount" result-set-metadata))
	 (column-names 
	  (loop for i from 1 to column-count
	       collect (#"getColumnName" result-set-metadata i))))
    (loop 
	 while (#"next" result-set)
	 collect (loop for i from 1 to column-count
		    collect 
		      (#"getString" result-set i)))))

(defun serialize-result-set-to-file (path)
  "Serialize a java.sql.ResultSet to file at PATH in a Lisp-readable
  format"
  (with-open-file (output path :direction :output)
    (write (serialize-result-set (get-procedures)) :stream output)))

(defvar *types-list*
  (map 'list 
       (lambda (field) 
	 (let ((name (#"getName" field)))
	   (list (get-java-field 'java.sql.Types name) name)))
       (#"getFields" (#"forName" 'java.lang.Class "java.sql.Types")))
  "java.sql.Types (value name) in a list")

;;; XXX depends on java.sql.Types constant details
(defvar *types-accessors*
  '((12 #"getString") 
    (1  #"getString")
    (5  #"getInt")
    (4  #"getInt")
    (2  #"getInt")   
;    (2  #"getBigDecimal")  ; XXX less precise, but more convenient 
    (3  #"getInt")
;    (3  #"getBigDecimal")  ; XXX less precise, but more convenient 
    (6  #"getFloat")
    (1111 #"getString") ; "OTHER" Oracle as "PL/SQL BOOLEAN"
    (-1 #"getString") ; Oracle LONGVARCHAR
    (8  #"getFloat"))
  "An alist of (integer function) of java.sql.Types integer mapped to
associated java.sql.ResultSet accessor function")

(defparameter *explicity-close-result-set* t
  "Whether to explicity close() a java.sql.ResultSet after reading,
  which can lead to JDBC bombing out with 'Too many open cursors' errors")

(defun serialize-result-set (result-set)
  "Return a list representation of each row from a java.sql.ResultSet"
  (declare (ignore column-names))
  (let* ((result-set-metadata (#"getMetaData" result-set))
	 (column-count (#"getColumnCount" result-set-metadata))
	 (column-names 
	  (loop for i from 1 to column-count
	       collect (#"getColumnName" result-set-metadata i)))
	 (column-accessors
	  (loop for i from 1 to column-count
	     collect (let* ((type (#"getColumnType" result-set-metadata i))
			    (accessor (assoc type *types-accessors*)))
		       (if accessor
			   (second accessor)
			   (progn
 			     (verbose "WARN: serializing column ~a of type ~a as string"
 				      i type)
			     #"getString"))))))
    (loop
       while (#"next" result-set)
       collect (loop for i from 1 to column-count
 		  collect (funcall (elt column-accessors (1- i))
 				   result-set i))
       finally 
	 (when *explicity-close-result-set*
	   (#"close" result-set)))))

(defun get-procedure-descriptions 
    (&key (catalog +java-null+) 
     (schema-pattern +java-null+) 
     (procedure-name-pattern "%")
     (column-name-pattern +java-null+))
  "Returns a java.sql.ResultSet describing the procedures parameter
and result columns."
  ;;; XXX Oracle barfs up NIL here somehow: maybe for catalog as
  ;;; length zero string ("")?
  (unless catalog
    (setf catalog +java-null+))
  (#"getProcedureColumns" *metadata* 
			  catalog schema-pattern procedure-name-pattern
			  column-name-pattern))

(defvar *procedure-column-types*
  (loop for type in '("procedureColumnUnknown" 
		      "procedureColumnIn"
		      "procedureColumnInOut"
		      "procedureColumnOut"
		      "procedureColumnReturn"
		      "procedureColumnResult")
       collect (list (get-java-field 'java.sql.DatabaseMetaData type)
		     type))
  "An alist mapping of java.sql.DatabaseMetaData procedure COLUMN-TYPE
  from integer to string") 

(defun get-catalogs-as-result-set () 
  (if *metadata* 
      (#"getCatalogs" *metadata*)
      (warn "No *metadata* to work with.  Invoke an DATBASE-init
function in 'database-init.lisp' to warm things up.")))


(defun serialize-procedure-description-from-result-set (rs)
  "Return list (INPUT-PARAMETERS OUTPUT-PARAMETERS) of a SQL procedure
  description, where each item of the parameter sequence is (name
  result-type remarks).  (Hopefully) calling order is preserved."

  (serialize-procedure-description (serialize-result-set rs)))

(defun serialize-procedure-description (columns)
  "Return list (INPUT-PARAMETERS OUTPUT-PARAMETERS) of a SQL procedure
  description, where each item of the parameter sequence is (name
  result-type remarks).  (Hopefully) calling order is preserved."
   (let ((input-parameters '())
	 (output-parameters '()))
     (dolist (column columns)
	(let ((column-name (fourth column))
	      (column-type (cadr (assoc (fifth column)
					*procedure-column-types*)))
;	      (data-type (cadr (assoc (sixth column) *types-list*)))
	      (data-type (seventh column))
	      (remarks (nth 12 column)))
	  (verbose "~a" (list column-name column-type data-type
			      remarks))
	  (macrolet ((push-results (destination)
		       `(push (list column-name data-type remarks)
			      ,destination)))
	    (cond ((equal column-type "procedureColumnReturn")
		   (push-results output-parameters))
		  ((equal column-type "procedureColumnIn")
		   (push-results input-parameters))
		  ((equal column-type "procedureColumnOut")
		   (push-results output-parameters))
		  ((equal column-type "procedureColumnInOut")
		   (push-results output-parameters)
		   (push-results input-parameters))))))
     (values (nreverse input-parameters) (nreverse output-parameters))))
	       

;;; XXX gonna need different types for different databases
(defvar *sql->xsd*
  '(("VARCHAR2" "xsd:string")
    ("DECIMAL" "xsd:decimal")
    ("DATE" "xsd:dateTime")
    ("PL/SQL RECORD" "plsql:oracle-pl-sql-record")
    ("REF CURSOR" "plsql:oracle-pl-sql-ref-cursor")
    ("PL/SQL TABLE" "plsql:oracle-pl-sql-table")
    ("CLOB" "xsd:base64Binary")
    ("PL/SQL BOOLEAN" "xsd:boolean")
    ("TABLE" "tns:oracle-table")
    ("NUMBER" "xsd:long")))

(defun sql-type->xsd (type)
  (let ((mapping (find type *sql->xsd* :test #'equal :key #'car)))
    (if mapping
	(cadr mapping)
	(progn 
	  (warn "Mapping unknown type '~A' as xsd:string" type)
	  "xsd:string"))))

(defun get-unique-procedure-catalogs (&key (schema "EUIDB"))
  (let ((procedures (get-procedures :schema-pattern schema)))
    (verbose "Processing ~A procedure descriptions in ~A" 
	     (length procedures) schema)
    (mapcar #'first (delete-duplicates procedures :test #'equal :key
				       #'first))))

(defun get-schemas () 
  (possibly-refresh-metadata)
  (let ((schemas
	(transcribe-result-set-as-strings 
	 (#"getSchemas" *metadata*))))
    (reduce #'append schemas)))
    